home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / Excel and 17833422001.psc / VB With Excel / ExcelFile.cls < prev    next >
Encoding:
Visual Basic class definition  |  2001-04-02  |  7.2 KB  |  245 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 1  'vbDataSource
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "ExcelFile"
  10. Attribute VB_GlobalNameSpace = True
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = True
  14. Option Explicit
  15.  
  16. Dim ExcelSheet      As Excel.Application
  17.  
  18. Dim LableNo         As Integer
  19. Dim ExcelColNo      As Integer
  20. Dim ExcelCel        As String
  21. Dim ExcelRow        As Integer
  22. Dim ColNoDB         As Integer
  23. Dim RowNoDB         As Integer
  24. Dim LineWidth       As Byte
  25.  
  26. Dim MakeDir         As FileSystemObject
  27. Dim NumberOfColumns As Integer
  28. Dim Counter         As Integer
  29. Dim BackCounter     As Integer
  30. Dim CaptionString   As String
  31. Dim HeadColName     As String
  32.  
  33. Dim FieldsCounter   As Integer
  34.  
  35. Private Const ExcelColumn_B = 98    'Ascii Value For : B
  36.  
  37.  
  38. Private Sub FillExcelSheet(ArrayValues() As String, FieldsCount As Integer)
  39. ' ******************************************************************************
  40. ' Routine:           FillExcelSheet
  41. ' Description:       set value to Excel Sheet
  42. ' Created by:        gil
  43. ' Machine:           GIL
  44. ' Date-Time:         25/06/00-16:09:00
  45. ' Last modification: last_modification_info_here
  46. ' ******************************************************************************
  47.  
  48. On Error GoTo ErrHandler
  49.  
  50. ExcelColNo = ExcelColumn_B
  51. ExcelCel = Empty
  52. ColNoDB = 0
  53. RowNoDB = 0
  54. ExcelRow = 2
  55.  
  56. '--- Fill All Cell(Row) In The First Column ---
  57. '--- Then Fill SEcond Column And So On ---
  58.  
  59. '--- Move From Column To The Next ---
  60. For ColNoDB = 0 To FieldsCount
  61.        '--- Move From One Row To The Next ---
  62.        For RowNoDB = LBound(ArrayValues) To UBound(ArrayValues)
  63.             ExcelCel = UCase(Chr(ExcelColNo)) & 2 + ExcelRow
  64.             ExcelSheet.Range(ExcelCel).Value = ArrayValues(RowNoDB, ColNoDB)
  65.             ExcelRow = ExcelRow + 1
  66.         Next RowNoDB
  67.     ExcelRow = 2
  68.     ExcelColNo = ExcelColNo + 1
  69.     ExcelCel = Empty
  70. Next ColNoDB
  71.  
  72.  
  73. Exit Sub
  74. ErrHandler:
  75.      MsgBox Err.Number & vbCrLf & Err.Description
  76. End Sub
  77.  
  78.  
  79. Private Sub FillExcelLables(ArrayFields() As String)
  80. ' ******************************************************************************
  81. ' Routine:           FillExcelLables
  82. ' Description:       Set Lables To The Excel Sheet Columns
  83. ' Created by:        gil
  84. ' Machine:           GIL
  85. ' Date-Time:         25/06/00-16:08:13
  86. ' Last modification: last_modification_info_here
  87. ' ******************************************************************************
  88.  
  89. On Error GoTo ErrHandler
  90.  
  91. ExcelSheet.Workbooks.Add
  92.  
  93. BackCounter = 0
  94.  
  95. For LableNo = LBound(ArrayFields) To UBound(ArrayFields)
  96.     '--- Make A Point To Excel Cel ---
  97.     '--- Always In Line 3  ---
  98.     ExcelCel = UCase(Chr(ExcelColNo)) & 3
  99.     
  100.     '--- Get Field Caption From DB ---
  101.     HeadColName = ArrayFields(LableNo)
  102.     
  103.     '--- Insert Field Caption To Excel Cel ---
  104.     ExcelSheet.Range(ExcelCel).Value = HeadColName
  105.     
  106.     '--- Increase Excel Column No ---
  107.     ExcelColNo = ExcelColNo + 1
  108.     BackCounter = BackCounter + 1
  109. Next LableNo
  110.  
  111.     '--- Keep Number Of Fields For Later Use ---
  112.     FieldsCounter = UBound(ArrayFields)
  113.  
  114. Exit Sub
  115. ErrHandler:
  116.      MsgBox Err.Number & vbCrLf & Err.Description
  117. End Sub
  118.  
  119. Public Function MakeExcelFile(FieldsArray() As String, ValuesArray() As String, FileNameToSave As String)
  120. ' ******************************************************************************
  121. ' Routine:           MakeExcelFile
  122. ' Description:       Save Excel File
  123. ' Created by:        gil
  124. ' Machine:           GIL
  125. ' Date-Time:         25/06/00-12:35:21
  126. ' Last modification: last_modification_info_here
  127. ' ******************************************************************************
  128.     
  129.     On Error GoTo ErrHandler
  130.     
  131.     Dim PathInRegesry As String
  132.     
  133.     Set ExcelSheet = CreateObject("excel.application")
  134.     Set MakeDir = New FileSystemObject
  135.  
  136.  
  137.     ExcelColNo = ExcelColumn_B
  138.     LableNo = 0
  139.  
  140.     '--- get file name and directory name from the user ---
  141.     If MakeDir.FolderExists("C:\ExcelFiles") = False Then
  142.         MakeDir.CreateFolder "C:\ExcelFiles"
  143.     End If
  144.         
  145.     Set MakeDir = Nothing
  146.       
  147.       
  148.     '--- set lable to Excel Sheet ---
  149.     Call FillExcelLables(FieldsArray)
  150.  
  151.     '--- set value to Excel Sheet
  152.     Call FillExcelSheet(ValuesArray, UBound(FieldsArray))
  153.  
  154.     '--- Change Excel Sheet View ---
  155.     Call SheetView
  156.  
  157.     '--- save the file ---
  158.     ExcelSheet.AlertBeforeOverwriting = False
  159.     ExcelSheet.ActiveWorkbook.SaveAs "C:\ExcelFiles\" & FileNameToSave
  160.        
  161.     ExcelSheet.Visible = True
  162.     
  163.     '--- end the Excel processes
  164.     'ExcelSheet.Quit
  165.     
  166.     
  167.     Set ExcelSheet = Nothing
  168.     
  169.     Exit Function
  170. ErrHandler:
  171.  
  172.     ExcelSheet.Quit
  173.     MsgBox Err.Number & vbCrLf & Err.Description
  174.     Set ExcelSheet = Nothing
  175.     
  176. End Function
  177.  
  178. Private Function SheetView()
  179.                      
  180. ' ******************************************************************************
  181. ' Routine:           OutOfBounds
  182. ' Description:       Change Sheet View , Font , Color
  183. ' Created by:        gil
  184. ' Machine:           GIL
  185. ' Date-Time:         03/07/00-15:38:40
  186. ' Last modification: last_modification_info_here
  187. ' ******************************************************************************
  188. On Error GoTo ErrHandler
  189.     
  190.     Dim CellRange As String
  191.     
  192.     '--- Get Range To Change  - Lable Range ---
  193.     CellRange = "B3:" & UCase(Chr(FieldsCounter + ExcelColumn_B)) & "3"
  194.  
  195.     '--- Change Fonts Property ---
  196.   With ExcelSheet
  197.     .Range(CellRange).Font.Bold = True
  198.     .Range(CellRange).Font.Size = 13
  199.     .Range(CellRange).Font.Color = vbRed
  200.     .Range(CellRange).Font.Italic = True
  201.     .Range(CellRange).Font.Underline = True
  202.  
  203.     ' --- Make a border -----
  204.     .Range(CellRange).Borders(xlEdgeLeft).LineStyle = xlContinuous
  205.     .Range(CellRange).Borders(xlEdgeLeft).Weight = xlMedium
  206.     .Range(CellRange).Borders(xlEdgeLeft).ColorIndex = 32
  207.     
  208.     .Range(CellRange).Borders(xlEdgeTop).LineStyle = xlContinuous
  209.     .Range(CellRange).Borders(xlEdgeTop).Weight = xlMedium
  210.     .Range(CellRange).Borders(xlEdgeTop).ColorIndex = 32
  211.     
  212.     .Range(CellRange).Borders(xlEdgeBottom).LineStyle = xlContinuous
  213.     .Range(CellRange).Borders(xlEdgeBottom).Weight = xlMedium
  214.     .Range(CellRange).Borders(xlEdgeBottom).ColorIndex = 32
  215.  
  216.     .Range(CellRange).Borders(xlEdgeRight).LineStyle = xlContinuous
  217.     .Range(CellRange).Borders(xlEdgeRight).Weight = xlMedium
  218.     .Range(CellRange).Borders(xlEdgeRight).ColorIndex = 32
  219.  
  220.     '--- Aligment selection -----------------------------
  221.     .Range(CellRange).HorizontalAlignment = xlRight
  222.     .Range(CellRange).VerticalAlignment = xlBottom
  223.     
  224.     '--- Change Width For All Columns Automatic ---
  225.     .Columns.AutoFit
  226.     
  227.     '--- Change Color Of CellRange - Lables Row ---
  228.     .Range(CellRange).Interior.Color = vbYellow
  229.     
  230.     '--- Change with for (A1:A1)
  231.     .Range("A3").Select
  232.     .Columns("A:A").ColumnWidth = 20
  233.      
  234.   End With
  235.   
  236. Exit Function
  237. ErrHandler:
  238.     ExcelSheet.Quit
  239.     MsgBox Err.Number & vbCrLf & Err.Description
  240.     Set ExcelSheet = Nothing
  241. End Function
  242.  
  243.  
  244.  
  245.